home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xscheme.arc / xsobj.c < prev    next >
C/C++ Source or Header  |  1989-01-29  |  9KB  |  358 lines
  1. /* xsobj.c - xscheme object-oriented programming support */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* external variables */
  9. extern LVAL xlenv,xlval;
  10. extern LVAL s_stdout;
  11.  
  12. /* local variables */
  13. static LVAL s_self,k_isnew;
  14. static LVAL class,object;
  15.  
  16. /* instance variable numbers for the class 'Class' */
  17. #define MESSAGES    1    /* list of messages */
  18. #define IVARS        2    /* list of instance variable names */
  19. #define CVARS        3    /* ctenv containing class variable names */
  20. #define CVALS        4    /* env containing class variable values */
  21. #define SUPERCLASS    5    /* pointer to the superclass */
  22. #define IVARCNT        6    /* number of class instance variables */
  23. #define IVARTOTAL    7    /* total number of instance variables */
  24.  
  25. /* number of instance variables for the class 'Class' */
  26. #define CLASSSIZE    7
  27.  
  28. /* forward declarations */
  29. FORWARD LVAL entermsg();
  30. FORWARD LVAL copylists();
  31.  
  32. /* xlsend - send a message to an object */
  33. xlsend(obj,sym)
  34.   LVAL obj,sym;
  35. {
  36.     LVAL msg,cls,p;
  37.  
  38.     /* look for the message in the class or superclasses */
  39.     for (cls = getclass(obj); cls; cls = getivar(cls,SUPERCLASS))
  40.     for (p = getivar(cls,MESSAGES); p; p = cdr(p))
  41.         if ((msg = car(p)) && car(msg) == sym) {
  42.         push(obj); ++xlargc; /* insert 'self' argument */
  43.         xlval = cdr(msg);    /* get the method */
  44.         xlapply();         /* invoke the method */
  45.         return;
  46.         }
  47.  
  48.     /* message not found */
  49.     xlerror("no method for this message",sym);
  50. }
  51.  
  52. /* xsendsuper - built-in function 'send-super' */
  53. xsendsuper()
  54. {
  55.     LVAL obj,sym,msg,cls,p;
  56.  
  57.     /* get the message selector */
  58.     sym = xlgasymbol();
  59.     
  60.     /* find the 'self' object */
  61.     for (obj = xlenv; obj; obj = cdr(obj))
  62.     if (ntype(car(obj)) == OBJECT)
  63.         goto find_method;
  64.     xlerror("not in a method",sym);
  65.  
  66. find_method:
  67.     /* get the message class and the 'self' object */
  68.     cls = getivar(getelement(car(cdr(obj)),0),SUPERCLASS);
  69.     obj = car(obj);
  70.     
  71.     /* look for the message in the class or superclasses */
  72.     for (; cls; cls = getivar(cls,SUPERCLASS))
  73.     for (p = getivar(cls,MESSAGES); p; p = cdr(p))
  74.         if ((msg = car(p)) && car(msg) == sym) {
  75.         push(obj); ++xlargc; /* insert 'self' argument */
  76.         xlval = cdr(msg);    /* get the method */
  77.         xlapply();         /* invoke the method */
  78.         return;
  79.         }
  80.  
  81.     /* message not found */
  82.     xlerror("no method for this message",sym);
  83. }
  84.  
  85. /* obisnew - default 'isnew' method */
  86. LVAL obisnew()
  87. {
  88.     LVAL self;
  89.     self = xlgaobject();
  90.     xllastarg();
  91.     return (self);
  92. }
  93.  
  94. /* obclass - get the class of an object */
  95. LVAL obclass()
  96. {
  97.     LVAL self;
  98.     self = xlgaobject();
  99.     xllastarg();
  100.     return (getclass(self));
  101. }
  102.  
  103. /* obshow - show the instance variables of an object */
  104. LVAL obshow()
  105. {
  106.     LVAL self,fptr,cls,names;
  107.     int maxi,i;
  108.  
  109.     /* get self and the file pointer */
  110.     self = xlgaobject();
  111.     fptr = (moreargs() ? xlgaoport() : getvalue(s_stdout));
  112.     xllastarg();
  113.  
  114.     /* get the object's class */
  115.     cls = getclass(self);
  116.  
  117.     /* print the object and class */
  118.     xlputstr(fptr,"Object is ");
  119.     xlprin1(self,fptr);
  120.     xlputstr(fptr,", Class is ");
  121.     xlprin1(cls,fptr);
  122.     xlterpri(fptr);
  123.  
  124.     /* print the object's instance variables */
  125.     names = cdr(getivar(cls,IVARS));
  126.     maxi = getivcnt(cls,IVARTOTAL);
  127.     for (i = 1; i <= maxi; ++i) {
  128.     xlputstr(fptr,"  ");
  129.     xlprin1(car(names),fptr);
  130.     xlputstr(fptr," = ");
  131.     xlprin1(getivar(self,i),fptr);
  132.     xlterpri(fptr);
  133.     names = cdr(names);
  134.     }
  135.  
  136.     /* return the object */
  137.     return (self);
  138. }
  139.  
  140. /* clnew - create a new object instance */
  141. clnew()
  142. {
  143.     LVAL self;
  144.  
  145.     /* create a new object */
  146.     self = xlgaobject();
  147.     xlval = newobject(self,getivcnt(self,IVARTOTAL));
  148.  
  149.     /* send the 'isnew' message */
  150.     xlsend(xlval,k_isnew);
  151. }
  152.  
  153. /* clisnew - initialize a new class */
  154. LVAL clisnew()
  155. {
  156.     LVAL self,ivars,cvars,super;
  157.     int n;
  158.  
  159.     /* get self, the ivars, cvars and superclass */
  160.     self = xlgaobject();
  161.     ivars = xlgalist();
  162.     cvars = (moreargs() ? xlgalist() : NIL);
  163.     super = (moreargs() ? xlgaobject() : object);
  164.     xllastarg();
  165.  
  166.     /* create the class variable compile-time environment */
  167.     xlval = cons(xlenter("%%CLASS"),copylists(cvars,NIL));
  168.     cpush(cons(xlval,getivar(super,CVARS)));
  169.     
  170.     /* create the class variable environment */
  171.     xlval = newvector(listlength(xlval)); setelement(xlval,0,self);
  172.     cpush(cons(xlval,getivar(super,CVALS)));
  173.  
  174.     /* store the instance and class variable lists and the superclass */
  175.     setivar(self,IVARS,copylists(getivar(super,IVARS),ivars));
  176.     setivar(self,CVALS,pop());
  177.     setivar(self,CVARS,pop());
  178.     setivar(self,SUPERCLASS,super);
  179.  
  180.     /* compute the instance variable count */
  181.     n = listlength(ivars);
  182.     setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
  183.     n += getivcnt(super,IVARTOTAL);
  184.     setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
  185.  
  186.     /* return the new class object */
  187.     return (self);
  188. }
  189.  
  190. /* clanswer - define a method for answering a message */
  191. LVAL clanswer()
  192. {
  193.     extern LVAL xlfunction();
  194.     LVAL self,msg,fargs,code,mptr;
  195.  
  196.     /* message symbol, formal argument list and code */
  197.     self = xlgaobject();
  198.     msg = xlgasymbol();
  199.     fargs = xlgetarg();
  200.     code = xlgalist();
  201.     xllastarg();
  202.  
  203.     /* make a new message list entry */
  204.     mptr = entermsg(self,msg);
  205.  
  206.     /* add 'self' to the argument list */
  207.     cpush(cons(s_self,fargs));
  208.  
  209.     /* extend the class variable environment with the instance variables */
  210.     xlval = cons(getivar(self,IVARS),getivar(self,CVARS));
  211.     
  212.     /* compile and store the method */
  213.     xlval = xlfunction(msg,top(),code,xlval);
  214.     rplacd(mptr,cvmethod(xlval,getivar(self,CVALS)));
  215.     drop(1);
  216.  
  217.     /* return the object */
  218.     return (self);
  219. }
  220.  
  221. /* addivar - enter an instance variable */
  222. LOCAL addivar(cls,var)
  223.   LVAL cls; char *var;
  224. {
  225.     setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
  226. }
  227.  
  228. /* addmsg - add a message to a class */
  229. LOCAL addmsg(cls,msg,fname)
  230.   LVAL cls; char *msg,*fname;
  231. {
  232.     LVAL mptr;
  233.  
  234.     /* enter the message selector */
  235.     mptr = entermsg(cls,xlenter(msg));
  236.  
  237.     /* store the method for this message */
  238.     rplacd(mptr,getvalue(xlenter(fname)));
  239. }
  240.  
  241. /* entermsg - add a message to a class */
  242. LOCAL LVAL entermsg(cls,msg)
  243.   LVAL cls,msg;
  244. {
  245.     LVAL lptr,mptr;
  246.  
  247.     /* lookup the message */
  248.     for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
  249.     if (car(mptr = car(lptr)) == msg)
  250.         return (mptr);
  251.  
  252.     /* allocate a new message entry if one wasn't found */
  253.     cpush(cons(msg,NIL));
  254.     setivar(cls,MESSAGES,cons(top(),getivar(cls,MESSAGES)));
  255.  
  256.     /* return the symbol node */
  257.     return (pop());
  258. }
  259.  
  260. /* getivcnt - get the number of instance variables for a class */
  261. LOCAL int getivcnt(cls,ivar)
  262.   LVAL cls; int ivar;
  263. {
  264.     LVAL cnt;
  265.     if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
  266.     xlerror("bad value for instance variable count",cnt);
  267.     return ((int)getfixnum(cnt));
  268. }
  269.  
  270. /* copylist - make a copy of a list */
  271. LOCAL LVAL copylists(list1,list2)
  272.   LVAL list1,list2;
  273. {
  274.     LVAL last,next;
  275.     
  276.     /* initialize */
  277.     cpush(NIL); last = NIL;
  278.     
  279.     /* copy the first list */
  280.     for (; consp(list1); list1 = cdr(list1)) {
  281.     next = cons(car(list1),NIL);
  282.     if (last) rplacd(last,next);
  283.     else settop(next);
  284.     last = next;
  285.     }
  286.     
  287.     /* append the second list */
  288.     for (; consp(list2); list2 = cdr(list2)) {
  289.     next = cons(car(list2),NIL);
  290.     if (last) rplacd(last,next);
  291.     else settop(next);
  292.     last = next;
  293.     }
  294.     return (pop());
  295. }
  296.  
  297. /* listlength - find the length of a list */
  298. LOCAL int listlength(list)
  299.   LVAL list;
  300. {
  301.     int len;
  302.     for (len = 0; consp(list); len++)
  303.     list = cdr(list);
  304.     return (len);
  305. }
  306.  
  307. /* obsymbols - initialize symbols */
  308. obsymbols()
  309. {
  310.     /* enter the object related symbols */
  311.     s_self  = xlenter("SELF");
  312.     k_isnew = xlenter("ISNEW");
  313.  
  314.     /* get the Object and Class symbol values */
  315.     object = getvalue(xlenter("OBJECT"));
  316.     class  = getvalue(xlenter("CLASS"));
  317. }
  318.  
  319. /* xloinit - object function initialization routine */
  320. xloinit()
  321. {
  322.     LVAL sym;
  323.     
  324.     /* create the 'Object' object */
  325.     sym = xlenter("OBJECT");
  326.     object = newobject(NIL,CLASSSIZE);
  327.     setvalue(sym,object);
  328.     setiv